home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / char.lisp < prev    next >
Encoding:
Text File  |  1992-03-10  |  4.1 KB  |  168 lines
  1. ;;; -*- Package: RT; Log: c.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice Lisp project at
  5. ;;; Carnegie-Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: char.lisp,v 1.3 92/03/10 10:00:34 wlott Exp $
  11. ;;; 
  12. ;;; This file contains the RT VM definition of character operations.
  13. ;;;
  14. ;;; Written by Rob MacLachlan and Bill Chiles.
  15. ;;;
  16.  
  17. (in-package "RT")
  18.  
  19.  
  20.  
  21. ;;;; Moves and coercions:
  22.  
  23. ;;; MOVE-TO-BASE-CHAR -- VOP.
  24. ;;;
  25. ;;; Move a tagged char to an untagged representation.
  26. ;;;
  27. (define-vop (move-to-base-char)
  28.   (:args (x :scs (any-reg descriptor-reg) :target y))
  29.   (:arg-types base-char)
  30.   (:results (y :scs (base-char-reg)))
  31.   (:generator 1
  32.     (move y x)
  33.     (inst sr y vm:type-bits)))
  34. ;;;
  35. (define-move-vop move-to-base-char :move
  36.   (any-reg descriptor-reg) (base-char-reg))
  37.  
  38.  
  39. ;;; MOVE-FROM-BASE-CHAR -- VOP.
  40. ;;;
  41. ;;; Move an untagged char to a tagged representation.
  42. ;;;
  43. (define-vop (move-from-base-char)
  44.   (:args (x :scs (base-char-reg) :target temp))
  45.   (:temporary (:scs (base-char-reg) :from (:argument 0)) temp)
  46.   (:results (y :scs (any-reg descriptor-reg)))
  47.   (:result-types base-char)
  48.   (:generator 1
  49.     (move temp x)
  50.     (inst sl temp vm:type-bits)
  51.     (inst oil y temp vm:base-char-type)))
  52. ;;;
  53. (define-move-vop move-from-base-char :move
  54.   (base-char-reg) (any-reg descriptor-reg))
  55.  
  56. ;;; BASE-CHAR-MOVE -- VOP.
  57. ;;;
  58. ;;; Move untagged base-char values.
  59. ;;;
  60. (define-vop (base-char-move)
  61.   (:args (x :target y
  62.         :scs (base-char-reg)
  63.         :load-if (not (location= x y))))
  64.   (:results (y :scs (base-char-reg)
  65.            :load-if (not (location= x y))))
  66.   (:effects)
  67.   (:affected)
  68.   (:generator 0
  69.     (move y x)))
  70. ;;;
  71. (define-move-vop base-char-move :move
  72.   (base-char-reg) (base-char-reg))
  73.  
  74.  
  75. ;;; MOVE-BASE-CHAR-ARGUMENT -- VOP.
  76. ;;;
  77. ;;; Move untagged base-char arguments/return-values.
  78. ;;;
  79. (define-vop (move-base-char-argument)
  80.   (:args (x :target y
  81.         :scs (base-char-reg))
  82.      (fp :scs (word-pointer-reg)
  83.          :load-if (not (sc-is y base-char-reg))))
  84.   (:results (y))
  85.   (:generator 0
  86.     (sc-case y
  87.       (base-char-reg
  88.        (move y x))
  89.       (base-char-stack
  90.        (storew x fp (tn-offset y))))))
  91. ;;;
  92. (define-move-vop move-base-char-argument :move-argument
  93.   (any-reg base-char-reg) (base-char-reg))
  94.  
  95.  
  96. ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
  97. ;;; to a descriptor passing location.
  98. ;;;
  99. (define-move-vop move-argument :move-argument
  100.   (base-char-reg) (any-reg descriptor-reg))
  101.  
  102.  
  103.  
  104. ;;;; Other operations:
  105.  
  106. ;;; CHAR-CODE -- VOP.
  107. ;;;
  108. ;;; This assumes it is best to keep characters in their raw representation.
  109. ;;;
  110. (define-vop (char-code)
  111.   (:translate char-code)
  112.   (:policy :fast-safe)
  113.   (:args (ch :scs (base-char-reg) :target temp))
  114.   (:arg-types base-char)
  115.   (:temporary (:scs (base-char-reg)
  116.             :from (:argument 0) :to (:result 0)
  117.             :target res) temp)
  118.   (:results (res :scs (any-reg)))
  119.   (:result-types positive-fixnum)
  120.   (:generator 1
  121.     (move temp ch)
  122.     (inst sl temp 2)
  123.     (move res temp)))
  124.  
  125. ;;; CODE-CHAR -- VOP.
  126. ;;;
  127. (define-vop (code-char)
  128.   (:translate code-char)
  129.   (:policy :fast-safe)
  130.   (:args (code :scs (any-reg) :target res))
  131.   (:arg-types positive-fixnum)
  132.   (:results (res :scs (base-char-reg)))
  133.   (:result-types base-char)
  134.   (:generator 1
  135.     (move res code)
  136.     (inst sr res 2)))
  137.  
  138.  
  139.  
  140. ;;; Comparison of base-chars.
  141. ;;;
  142. (define-vop (base-char-compare)
  143.   (:args (x :scs (base-char-reg))
  144.      (y :scs (base-char-reg)))
  145.   (:arg-types base-char base-char)
  146.   (:conditional)
  147.   (:info target not-p)
  148.   (:policy :fast-safe)
  149.   (:note "inline comparison")
  150.   (:variant-vars condition)
  151.   (:generator 6
  152.     (inst cl x y)
  153.     (if not-p
  154.     (inst bnc condition target)
  155.     (inst bc condition target))))
  156.  
  157. (define-vop (fast-char=/base-char base-char-compare)
  158.   (:translate char=)
  159.   (:variant :eq))
  160.  
  161. (define-vop (fast-char</base-char base-char-compare)
  162.   (:translate char<)
  163.   (:variant :lt))
  164.  
  165. (define-vop (fast-char>/base-char base-char-compare)
  166.   (:translate char>)
  167.   (:variant :gt))
  168.